module BrainFuck (module BrainFuck) where

import Data.Char

-- Environment

type Env = ([Int], Int)

initEnv = ([0], 0) :: Env

-- > & <

rightShift :: Env -> Env
rightShift (xs, i) = if i+1 >= length xs then (xs++[0], i+1) else (xs, i+1)

leftShift :: Env -> Env
leftShift (xs, i) = if i==0 then (0:xs, 0) else (xs, i-1)

-- +

inc :: Env -> Env
inc (xs, i) = (
    if length xs > i
    then take i xs ++ [min 255 $ (+1) $ head $ drop i xs] ++ (tail $ drop i xs)
    else xs
    , i
    )

-- -

dec :: Env -> Env
dec (xs, i) = (
    if length xs > i
    then take i xs ++ [max 0 $ (+(-1)) $ head $ drop i xs] ++ (tail $ drop i xs)
    else xs
    , i
    )


-- Code Operation

type Code = (String, Int)

initCode code = (code, 0) :: Code

-- normal read

readCode :: Code -> Code
readCode (code, p) = (code, p+1)

-- [

-- findNext: find the leftmost char appears behind index p. 
-- This function is unsafe for index p may become out of bound.

findNext :: Char -> String -> Int -> Int
findNext c code p = if code!!p == c then p else findNext c code (p+1)

-- jumpFront: code ptr jump to the location of the leftmost ] with the current location being p

jumpFront :: Code -> Code
jumpFront (code, p) = (code, findNext ']' code p)

-- ]

-- findPrev: find the rightmost char appears before index p. 
-- This function is unsafe for index p may become less than zero.

findPrev :: Char -> String -> Int -> Int
findPrev c code p = if code!!p == c then p else findPrev c code (p-1)

-- jumpBehind: code ptr jump to the location of the rightmost [ with the current location being p

jumpBehind :: Code -> Code
jumpBehind (code, p) = (code, findPrev '[' code p)


-- Interaction with outer environment

type Io = (String, String)

initIo inp = (inp, "") :: Io

writeEnv :: Char -> Env -> Env
writeEnv c (xs, i) = (take i xs ++ [ord c] ++ (tail $ drop i xs), i)

readEnv :: Env -> Char
readEnv (xs, i) = chr (xs !! i)

-- Execute brainfuck program

execute :: Env -> Code -> Io -> String
execute env cd io = 
    let 
        (xs, i) = env
        (code, p) = cd
        (inp, outp) = io
    in if length code == p
        then outp
        else case code !! p of
            '>' -> execute (rightShift env) (readCode cd) io
            '<' -> execute (leftShift env) (readCode cd) io
            '+' -> execute (inc env) (readCode cd) io
            '-' -> execute (dec env) (readCode cd) io
            '[' -> if xs!!i == 0
                then execute env (jumpFront cd) io
                else execute env (readCode cd) io
            ']' -> if xs!!i /= 0
                then execute env (jumpBehind cd) io
                else execute env (readCode cd) io
            '.' -> execute env (readCode cd) (inp, outp++[readEnv env])
            ',' -> let inpc:inps = inp 
                in execute (writeEnv inpc env) (readCode cd) (inps, outp)
            otherwise -> execute env (readCode cd) io

eval :: (String, String) -> String
eval (code, inp) = execute initEnv (initCode code) (initIo inp)

-- testing

-- test1 = eval (
--     ",----------[----------------------.,----------]",
--     "ab\n"
--     ) -- "AB"
-- helloworld = eval (
--     ">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]"
--     ++ "<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++["
--     ++ "<++++>-]<+.[-]++++++++++.",
--     ""
--     )